home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tools / doloop / ISTUD.MAC.f < prev   
Encoding:
Text File  |  1989-03-04  |  39.7 KB  |  1,168 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 2.1
  3. C---------------------------------------------------------
  4. C
  5. C    - REMOVE TABS
  6. C    - PROGRAM UNITS RE-ORDERED
  7. C    - ADDITIONAL YADEFS INCLUSIONS REMOVED
  8. C    - DEFINES MOVED
  9. C    - UNSPLIT LINES REMOVED
  10. C    - CHANGE ZPTYPE TO ZPTYPE
  11. C    - USE NEW TOKEN WRITE ROUTINE, CHANGE IODTKO/IODCMO FOR
  12. C      TKNCHN AND USE ZTKPTI AS AN INITIALISATION CALL.
  13. C
  14. C--------   ISTUD.MAC
  15. C---------------------------------------------------------
  16. C    TOOLPACK/1    Release: 2.1
  17. C---------------------------------------------------------
  18. C---------------------------------------------------------
  19. C    TOOLPACK/1    Release: 2.1
  20. C---------------------------------------------------------
  21. C---------------------------------------------------------
  22. C    TOOLPACK/1    Release: 2.1
  23. C---------------------------------------------------------
  24.  
  25.  
  26.  
  27.  
  28.  
  29.  
  30.  
  31.  
  32. C                                   parameter length
  33.  
  34.  
  35.  
  36.  
  37.  
  38.  
  39.  
  40.  
  41.  
  42. C following are for ZYCSDT (Canonicalise Symbol Data Types)
  43. C
  44.       PROGRAM ISTUD
  45.  
  46.       COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  47.       INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  48.  
  49.       COMMON/UNR/ DEPTH
  50.       INTEGER DEPTH(3)
  51.  
  52.       INTEGER TKNPTH(81),CIPTH(81),NERROR,NWARN,
  53.      +        TKOPTH(81),CMOPTH(81),CMTPTH(81),JUNK
  54.  
  55.       INTEGER OPEN,CREATE,GETARG,YPARSE,ZYINCI
  56.  
  57.       SAVE
  58.         DATA (CIPTH(I),I=1,10)/35,
  59.      +117,100,99,109,105,116,109,112,129/
  60.  
  61.       CALL ZINIT
  62.       CALL INISTR
  63.       CALL INISYM
  64.       CALL INITRE
  65.       NERROR = 0
  66.       NWARN = 0
  67.  
  68.       IF (GETARG(1,TKNPTH,81).EQ.-100) CALL NAMES(1,TKNPTH)
  69.       IF (GETARG(2,CMTPTH,81).EQ.-100) CALL NAMES(2,CMTPTH)
  70.       IF (GETARG(3,TKOPTH,81).EQ.-100) CALL NAMES(3,TKOPTH)
  71.       IF (GETARG(4,CMOPTH,81).EQ.-100) CALL NAMES(4,CMOPTH)
  72.       IF (GETARG(5,DEPTH,3).EQ.-100)        CALL NAMES(5,DEPTH)
  73.  
  74.       IODTKN=OPEN(TKNPTH,0)
  75.       IF (IODTKN.EQ.-1) CALL ERROR('Can''t open token file.')
  76.       IODCMT=OPEN(CMTPTH,0)
  77.       IF (IODCMT.EQ.-1) CALL ERROR('Can''t open comment file.')
  78.       IODTKO=CREATE(TKOPTH,1)
  79.       IF (IODTKO.EQ.-1) CALL ERROR('Can''t create token stream.')
  80.       IODCMO=CREATE(CMOPTH,1)
  81.       IF (IODCMO.EQ.-1) CALL ERROR('Can''t create comment stream.')
  82.  
  83.       IODCMI=CREATE(CIPTH,2)
  84.       IF (IODCMO.EQ.-1) CALL ERROR('Can''t create scratch file.')
  85.  
  86.       IF(YPARSE(IODTKN,IODCMT,-1,IODCMI,NERROR,NWARN).NE.0) THEN
  87.         CALL ERROR('[ISTUD - PARSER FATAL ERROR].')
  88.       ENDIF
  89.  
  90.       IF(NERROR .GT. 0) THEN
  91.         CALL ERROR('[ISTUD - PARSER ERRORS REPORTED].')
  92.       ENDIF
  93.  
  94.       CALL SEEK(0, IODCMI)
  95.       CALL SEEK(0, IODCMT)
  96.       IF(ZYINCI(IODCMI) .EQ. -1) CALL ERROR('[ISTUD - ZYINCI ERROR].')
  97.  
  98.       CALL PROFIL
  99.  
  100.       CALL ZMESS('[ISTUD Normal Termination].',2)
  101.       CALL ZQUIT(-2)
  102.  
  103.       END
  104. C ----------------------------------------------------------------------
  105. C
  106.       SUBROUTINE NAMES (NUMBER,PATH)
  107.  
  108.       INTEGER NUMBER,PATH(81)
  109.  
  110.       INTEGER ZGTCMD
  111.       EXTERNAL ZGTCMD,ZPRMPT
  112.  
  113.       INTEGER JUNK,PROMPT(24,5)
  114.  
  115.       SAVE PROMPT
  116.  
  117. C "Input token stream: "
  118. C "Input comment stream: "
  119. C "Output token stream: "
  120. C "Output comment stream: "
  121. C "Input unrolling depth: "
  122.  
  123.       DATA (PROMPT(I,1),I=1,21)/73,110,112,117,116,32,116,
  124.      +111,107,101,110,32,115,116,114,101,97,109,
  125.      +58,32,129/,
  126.      +     (PROMPT(I,2),I=1,23)/73,110,112,117,116,32,99,
  127.      +111,109,109,101,110,116,32,115,116,114,101,97,109,
  128.      +58,32,129/,
  129.      +     (PROMPT(I,3),I=1,22)/79,117,116,112,117,116,32,
  130.      +116,111,107,101,110,32,115,116,114,101,97,109,
  131.      +58,32,129/,
  132.      +     (PROMPT(I,4),I=1,24)/79,117,116,112,117,116,32,
  133.      +99,111,109,109,101,110,116,32,115,116,114,101,97,
  134.      +109,58,32,129/
  135.      +     (PROMPT(I,5),I=1,24)/73,110,112,117,116,32,
  136.      +117,110,114,111,108,108,105,110,103,32,100,101,
  137.      +112,116,104,58,32,129/
  138.  
  139.       CALL ZPRMPT(PROMPT(1,NUMBER))
  140.       JUNK=ZGTCMD(PATH,0)
  141.  
  142.       END
  143. C ----------------------------------------------------------------------
  144. C
  145. C       P R O F I L   -   Process files
  146. C
  147.  
  148.       SUBROUTINE PROFIL
  149.  
  150.       COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  151.       INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  152.  
  153.       COMMON /CLAB/ CURLBL,CURPUN, FIRST
  154.       LOGICAL FIRST
  155.       INTEGER CURLBL,CURPUN
  156.       INTEGER TEXT(134), SYMVAL(8)
  157.  
  158. C---------------------------------------------------------
  159. C    TOOLPACK/1    Release: 2.1
  160. C---------------------------------------------------------
  161. C
  162. C  TKLAST = LAST TOKEN NUMBER
  163. C
  164.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  165.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  166.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  167.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  168.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  169.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  170.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  171.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  172.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  173.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  174.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  175.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  176.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  177.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  178.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  179.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  180.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  181.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  182.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  183.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  184.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  185.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  186.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  187.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  188.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  189.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  190.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  191.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  192.  
  193.  
  194.       INTEGER ZYDOWN,ZYNEXT,ZYROOT,ZTKPTI,ZYGPUS
  195.       EXTERNAL ZYDOWN,ZYNEXT,ZYROOT,ZTOKWR,ZTKPTI,ZYGPUS,
  196.      +         GETSTR,PROPU,ZCHOUT,ZPTMES
  197.  
  198.       SAVE
  199.  
  200.       INTEGER PTR
  201.  
  202.       TKNCHN = ZTKPTI(1, IODTKO, IODCMO)
  203.       IF(TKNCHN .EQ. -1) CALL ERROR('[ISTUD - Output Stream Failure].')
  204.  
  205.       PTR=ZYDOWN(ZYROOT())
  206.       CURPUN = 0
  207.  
  208.   100 IF (PTR.GT.0) THEN
  209.         CURLBL = 69999
  210.         CURPUN = CURPUN + 1
  211.         FIRST = .TRUE.
  212.         CALL ZYGTSY(ZYGPUS(CURPUN), SYMVAL)
  213.         CALL ZYGTST(SYMVAL(2), TEXT)
  214.         CALL ZCHOUT('UD Processing: ', 2)
  215.         CALL ZPTMES(TEXT, 2)
  216.         CALL PROPU(PTR)
  217.         PTR=ZYNEXT(PTR)
  218.         GO TO 100
  219.       END IF
  220.       CALL ZTOKWR(TZEOF,0,TEXT,TKNCHN)
  221.  
  222.       END
  223. C-----------------------   GETIL.MAC
  224.       SUBROUTINE GETIL(DOVAR, LABEL)
  225. C Generate a variable and a label for use by ISTCD.  Each call
  226. C results in DOVAR being set (as an IST string) to the next member of the
  227. C sequence Mxxxxx, Myyyyy, (where yyyyy is xxxxx decremented by 1) ...
  228. C and LABEL being set (as an IST string) to the corresponding string
  229. C without the leading 'M'.  The first value of xxxxx is CURLBL in COMMON
  230. C block CLAB.
  231.  
  232.       INTEGER DOVAR(7),LABEL(6),RESULT(8), ZYFSYM
  233.  
  234.       COMMON /CLAB/ CURLBL,CURPUN
  235.       INTEGER CURLBL,CURPUN
  236.       LOGICAL FIRST
  237.       EXTERNAL ZITOCP, ZYFSYM, SCOPY
  238.  
  239.       SAVE
  240.  
  241.    10 CONTINUE
  242.       CALL ZITOCP(CURLBL,LABEL,5,48)
  243.       DOVAR(1) = 77
  244.       CALL SCOPY(LABEL,1,DOVAR,2)
  245.       DOVAR(7) = 129
  246.  
  247.       IF(ZYFSYM(DOVAR, CURPUN, RESULT) .NE. -1 .OR.
  248.      +   ZYFSYM(LABEL, CURPUN, RESULT) .NE. -1) THEN
  249.         CURLBL = CURLBL - 1
  250.         GO TO 10
  251.       ENDIF
  252.  
  253.       CURLBL = CURLBL - 1
  254.  
  255.       END
  256. C-----------------------   TITLE.MAC
  257.       SUBROUTINE TITLE(LABEL, STRING)
  258.  
  259.       CHARACTER*(*) STRING
  260.       LOGICAL FIRST
  261.       INTEGER LABEL(*)
  262.       COMMON /CLAB/ CURLBL,CURPUN, FIRST
  263.       INTEGER CURLBL,CURPUN
  264.  
  265.       SAVE
  266.  
  267.       IF(FIRST) THEN
  268.         CALL ZMESS(' - DO loops n'//'ot unrolled as follows:.',2)
  269.         FIRST = .FALSE.
  270.       ENDIF
  271.  
  272.       CALL ZCHOUT('   .', 2)
  273.       IF(LABEL(1) .NE. 129) THEN
  274.         CALL ZCHOUT(STRING, 2)
  275.         CALL ZCHOUT(' (.', 2)
  276.         CALL PUTLIN(LABEL, 2)
  277.         CALL ZMESS(').', 2)
  278.       ELSE
  279.         CALL ZMESS(STRING, 2)
  280.       ENDIF
  281.  
  282.       END
  283. C--------   NDEQM1.MAC
  284.       INTEGER FUNCTION NDEQM1(NODE)
  285. C Return 'yes' or 'no' according to whether the subtree rooted
  286. C at NODE represents the constant -1 when all outer parentheses
  287. C are removed.
  288. C
  289. C  MODIFIED TO HANDLE NODE=0 CASE
  290. C
  291.       INTEGER NODE
  292.  
  293.       COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  294.       INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  295.  
  296.       INTEGER POINTR,CONONE(2),TEXT(10)
  297.  
  298.       INTEGER NODETP, ZYDOWN, ZYNEXT,EQUAL
  299.       EXTERNAL NODETP,ZYDOWN,ZYNEXT,EQUAL,GETSTR
  300.  
  301.       DATA CONONE/49,129/
  302.  
  303.       NDEQM1 = -3
  304.       IF(NODE .EQ. 0) RETURN
  305.  
  306.       POINTR = NODE
  307.  
  308. C Remove outer parentheses
  309.    10 CONTINUE
  310.       IF (NODETP(POINTR) .EQ. 101) THEN
  311.          POINTR = ZYDOWN(POINTR)
  312.          GO TO 10
  313.       END IF
  314.  
  315.       IF (NODETP(POINTR) .NE. 46) RETURN
  316.  
  317.       POINTR = ZYDOWN(POINTR)
  318.       IF (NODETP(POINTR) .NE. 107) RETURN
  319.  
  320.       CALL GETSTR(POINTR,TEXT)
  321.       IF (EQUAL(TEXT,CONONE) .NE. -2) RETURN
  322.  
  323.       NDEQM1 = -2
  324.  
  325.       END
  326. C--------   PROPU.MAC
  327. C ----------------------------------------------------------------------
  328. C
  329. C       P R O P U   -   Process Program-Unit
  330. C
  331.  
  332.       SUBROUTINE PROPU(PUROOT)
  333.       INTEGER PUROOT
  334.  
  335.       INTEGER SPTR,SNUM,DOVAR(132),TYPE,
  336.      +        ICON(4),WIDTH,J,SYMVAL(8),
  337.      +        LBLNOD,TEXT(6),LABTRM(6),FIRST,VARNOD,E2NOD,
  338.      +        DUMMY(2),NUM1(2),POINT,IDEP,NEWLBL(6),LAST,E1NOD,
  339.      +        ITER(7),DOLBL(6),POINTR,E3NOD,E2DASH(7),JUNK(6),
  340.      +        COM1(40),LABLN(6),NRDIGS,INCNOD,SAVCOM,IOD,JJ
  341.  
  342.       LOGICAL UNROLL,ISLBLD,FOUND
  343.  
  344.       COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  345.       INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  346.  
  347.       COMMON/UNR/ DEPTH
  348.       INTEGER DEPTH(3)
  349.  
  350.       COMMON/LABLST/OLDLBS,NEWLBS,NRLBS
  351.       INTEGER OLDLBS(6,200),NEWLBS(6,200),NRLBS
  352.  
  353.       INTEGER ZYDOWN,ZYNEXT,LENGTH,NAMEP,NODETP,
  354.      +        EQUAL,CTOI,ZYPREV,URCOND,ITOC,NDEQM1
  355.       EXTERNAL ZYDOWN,ZYNEXT,LENGTH,YSTMT,ZTOKWR,
  356.      +         NAMEP,PUTLIN,ZCHOUT,ZPTINT,PUTCH,NODETP,UASGU,
  357.      +         ZYGTSY,ZYGTST,CTOI,ZYPREV,URCOND,GETIL,
  358.      +         SCOPY,COMOUT,YEXPR,SETLAB,ERROR,UDO,DOTRM,GETLAB,
  359.      +         UIF,IFLAB,ITOC,NDEQM1
  360.  
  361. C---------------------------------------------------------
  362. C    TOOLPACK/1    Release: 2.1
  363. C---------------------------------------------------------
  364. C
  365. C  TKLAST = LAST TOKEN NUMBER
  366. C
  367.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  368.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  369.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  370.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  371.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  372.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  373.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  374.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  375.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  376.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  377.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  378.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  379.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  380.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  381.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  382.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  383.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  384.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  385.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  386.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  387.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  388.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  389.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  390.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  391.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  392.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  393.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  394.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  395.  
  396.  
  397.       SAVE
  398.  
  399.       DATA DUMMY(1)/129/, NUM1/49,129/, SNUM/1/, UNROLL/.FALSE./
  400.  
  401. C "C *** DO-loop unrolled to depth ..."
  402.       DATA (COM1(JJ),JJ=1,31)/67,42,42,42,32,
  403.      +        68,79,45,108,111,111,
  404.      +        112,32,117,110,114,111,108,108,101,100,
  405.      +        32,116,111,32,100,101,112,116,104,32/
  406. C Fill in depth.
  407.  
  408.       DO 25 JJ = 1,3
  409.          IF (DEPTH(JJ) .EQ. 129) GO TO 30
  410.          COM1(JJ+31) = DEPTH(JJ)
  411.    25 CONTINUE
  412.  
  413.    30 CONTINUE
  414.       COM1(JJ+31) = 32
  415.       COM1(JJ+32) = 42
  416.       COM1(JJ+33) = 42
  417.       COM1(JJ+34) = 42
  418.       COM1(JJ+35) = 129
  419.  
  420. C Convert unrolling depth to integer.
  421.       POINT = 1
  422.       IDEP = CTOI(DEPTH,POINT)
  423.  
  424.       SPTR=ZYDOWN(PUROOT)
  425.  
  426.   100 TYPE = NODETP(SPTR)
  427.  
  428. C If a DO is encountered and unrolling is not underway, determine its
  429. C characteristics, test whether it meets the conditions for unrolling,
  430. C and, if it does, set up unrolling.
  431.       IF(TYPE .EQ. 61 .AND. .NOT. UNROLL) THEN
  432.  
  433. C If the DO statement has a label, LBLNOD is the label node, otherwise,
  434. C LBLNOD is the label reference node.
  435.          LBLNOD = ZYDOWN(SPTR)
  436.          IF (NODETP(LBLNOD) .EQ. 115) THEN
  437.  
  438. C Get the label.
  439.             DOLBL(1) = 129
  440.               CALL ZYGTSY(-ZYDOWN(LBLNOD),SYMVAL)
  441.               CALL ZYGTST(SYMVAL(2),DOLBL)
  442.             LBLNOD = ZYNEXT(LBLNOD)
  443.             ISLBLD = .TRUE.
  444.          ELSE
  445.             ISLBLD = .FALSE.
  446.          END IF
  447. C LBLNOD is now the label reference for the DO.
  448.  
  449. C Get label reference.  This marks the end of the loop.
  450. C Because the DO loop is assumed to be regular, this label
  451. C is on a CONTINUE.
  452.          LABTRM(1) = 129
  453.            CALL ZYGTSY(-ZYDOWN(LBLNOD),SYMVAL)
  454.            CALL ZYGTST(SYMVAL(2),LABTRM)
  455. C Get DO variable.
  456.          DOVAR(1) = 129
  457.          VARNOD = ZYDOWN(ZYNEXT(LBLNOD))
  458.            CALL ZYGTSY(-ZYDOWN(VARNOD),SYMVAL)
  459.            CALL ZYGTST(SYMVAL(2),DOVAR)
  460.  
  461. C Test whether the DO satisfies the conditions for unrolling.
  462.          IF (URCOND(SPTR,ISLBLD,DOVAR,LABTRM) .EQ. -3) GO TO 700
  463.          UNROLL = .TRUE.
  464.  
  465. C Output a comment that loop is to be unrolled.
  466.            CALL ZTOKWR(TCMMNT,LENGTH(COM1),COM1,TKNCHN)
  467.            CALL ZCHOUT('Unrolling loop labelled .',2)
  468.            CALL PUTLIN(LABTRM, 2)
  469.            CALL ZCHOUT(' to depth: .',2)
  470.            CALL ZPTMES(DEPTH, 2)
  471.  
  472. C Assemble information for the preamble and the modified DO.
  473.  
  474. C Lower limit E1.
  475.          E1NOD = ZYNEXT(VARNOD)
  476.  
  477. C Upper limit E2.
  478.          E2NOD = ZYNEXT(E1NOD)
  479.  
  480. C Incrementation parameter E3.  If E3NOD = 0 then the incrementation
  481. C parameter is default (1).
  482.          E3NOD = ZYNEXT(E2NOD)
  483.          IF (E3NOD .NE. 0) CALL REMARK('DO Loop With Incrementation'
  484.      +     //' Parameter Not Default: Check Regularity Condition 3.')
  485.  
  486. C Write the iteration count statement: Mxxxxx = (E2-E1+E3)/(d*E3)
  487. C If the original DO is labelled, write the label on the iteration
  488. C count statement.
  489.          IF (ISLBLD)
  490.      +        CALL ZTOKWR(TDCNST,LENGTH(DOLBL),DOLBL,TKNCHN)
  491. C Mxxxxx generated by GETIL
  492.          CALL GETIL(ITER,NEWLBL)
  493.            CALL ZTOKWR(TNAME,LENGTH(ITER),ITER,TKNCHN)
  494. C =
  495.            CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
  496. C (
  497.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  498. C E2
  499.          CALL YEXPR(E2NOD,TKNCHN)
  500. C -
  501.            CALL ZTOKWR(TMINUS,0,DUMMY(1),TKNCHN)
  502. C (E1)
  503.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  504.          CALL YEXPR(E1NOD,TKNCHN)
  505.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  506. C +
  507.            CALL ZTOKWR(TPLUS,0,DUMMY(1),TKNCHN)
  508. C (E3) or 1
  509.          IF (E3NOD .NE. 0) THEN
  510.               CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  511.             CALL YEXPR(E3NOD,TKNCHN)
  512.               CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  513.          ELSE
  514.             CALL ZTOKWR(TDCNST,LENGTH(NUM1),NUM1,TKNCHN)
  515.          END IF
  516. C )
  517.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  518. C /
  519.            CALL ZTOKWR(TSLASH,0,DUMMY(1),TKNCHN)
  520. C (
  521.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  522. C unrolling depth
  523.            CALL ZTOKWR(TDCNST,LENGTH(DEPTH),DEPTH,TKNCHN)
  524. C *(E3) - omit if E3 is default (1).
  525.          IF (E3NOD .NE. 0) THEN
  526.               CALL ZTOKWR(TSTAR,0,DUMMY(1),TKNCHN)
  527.               CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  528.             CALL YEXPR(E3NOD,TKNCHN)
  529.               CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  530.          END IF
  531. C )
  532.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  533. C end-of-statement (iteration count statement)
  534.            CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  535.  
  536. C Write the statement to calculate E2'=Myyyyy=E1+d*(E3)*(Mxxxxx-1)
  537. C Myyyyy generated by GETIL
  538.          CALL GETIL(E2DASH,JUNK)
  539.            CALL ZTOKWR(TNAME,LENGTH(E2DASH),E2DASH,TKNCHN)
  540. C =
  541.            CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
  542. C E1
  543.          CALL YEXPR(E1NOD,TKNCHN)
  544. C +
  545.            CALL ZTOKWR(TPLUS,0,DUMMY(1),TKNCHN)
  546. C unrolling depth
  547.            CALL ZTOKWR(TDCNST,LENGTH(DEPTH),DEPTH,TKNCHN)
  548. C *(E3) - omit if E3 = default (1)
  549.          IF (E3NOD .NE. 0) THEN
  550.               CALL ZTOKWR(TSTAR,0,DUMMY(1),TKNCHN)
  551.               CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  552.             CALL YEXPR(E3NOD,TKNCHN)
  553.               CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  554.          END IF
  555. C *
  556.            CALL ZTOKWR(TSTAR,0,DUMMY(1),TKNCHN)
  557. C (
  558.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  559. C iteration count
  560.            CALL ZTOKWR(TNAME,LENGTH(ITER),ITER,TKNCHN)
  561. C -
  562.            CALL ZTOKWR(TMINUS,0,DUMMY(1),TKNCHN)
  563. C 1
  564.          CALL ZTOKWR(TDCNST,LENGTH(NUM1),NUM1,TKNCHN)
  565. C )
  566.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  567. C end-of-statement (statement to calculate E2'=Myyyyy)
  568.            CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  569.  
  570. C Write the modified DO statement.
  571. C DO
  572.            CALL ZTOKWR(TDO,0,DUMMY(1),TKNCHN)
  573. C label reference
  574.            CALL ZTOKWR(TDCNST,LENGTH(LABTRM),LABTRM,TKNCHN)
  575. C DO variable
  576.            CALL ZTOKWR(TNAME,LENGTH(DOVAR),DOVAR,TKNCHN)
  577. C =
  578.            CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
  579. C E1
  580.          CALL YEXPR(E1NOD,TKNCHN)
  581. C ,
  582.            CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
  583. C E2' = Myyyyy
  584.            CALL ZTOKWR(TNAME,LENGTH(E2DASH),E2DASH,TKNCHN)
  585. C ,
  586.            CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
  587. C unrolling depth
  588.            CALL ZTOKWR(TDCNST,LENGTH(DEPTH),DEPTH,TKNCHN)
  589. C *(E3) - omit if E3 = default (1)
  590.          IF (E3NOD .NE. 0) THEN
  591.               CALL ZTOKWR(TSTAR,0,DUMMY(1),TKNCHN)
  592.               CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  593.             CALL YEXPR(E3NOD,TKNCHN)
  594.               CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  595.          END IF
  596. C end-of-statement (modified DO)
  597.            CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  598.          SNUM = SNUM + 1
  599.          CALL COMOUT(SNUM)
  600.  
  601. C Save statement number in preparation
  602. C for repeating comments in the clean-up loop.
  603.          SAVCOM = SNUM
  604.  
  605. C FIRST is the first statement to be replicated in unrolling.
  606.            SPTR = ZYNEXT(SPTR)
  607.          FIRST = SPTR
  608.          J = 0
  609.       END IF
  610. C End of set up for unrolling.
  611.   700 CONTINUE
  612.  
  613.  
  614.       IF(UNROLL) THEN
  615. C We are outputing statements in the body of the loop.
  616.          WIDTH = 4
  617. C Check whether we have reached the end of the range and, if so, set up
  618. C for another unrolling pass or, if finished with unrolling, write the
  619. C clean-up loop.
  620.          LBLNOD = ZYDOWN(SPTR)
  621.            IF(NODETP(LBLNOD) .EQ. 115) THEN
  622.              CALL ZYGTSY(-ZYDOWN(LBLNOD),SYMVAL)
  623.              CALL ZYGTST(SYMVAL(2),TEXT)
  624.  
  625. C Since all labels must be on CONTINUEs, the possibility of a labelled
  626. C statement that is not a DO terminator is covered in the special
  627. C treatment of CONTINUEs; at this point, we simply go on when such a
  628. C statement is encountered.
  629.              IF (EQUAL(TEXT,LABTRM) .EQ. -3) THEN
  630.                CONTINUE
  631.              ELSE IF(EQUAL(TEXT,LABTRM) .EQ. -2
  632.      +                .AND. J .LT. (IDEP - 1)) THEN
  633. C The range will be repeated with the DO variable increased by E3.
  634.                LAST = ZYPREV(SPTR)
  635. C Set up and/or reset the correspondence between old and new labels.
  636.                CALL SETLAB(FIRST,LAST,J)
  637.                J = J + 1
  638.                SPTR = FIRST
  639.              ELSE
  640. C We've arrived at the CONTINUE with the label LABTRM and unrolling is
  641. C complete.  Output the CONTINUE, save LAST for the clean-up loop and
  642. C turn off unrolling.
  643.  
  644.                CALL YSTMT(SPTR,TKNCHN)
  645.                SNUM = SNUM + 1
  646.                CALL COMOUT(SNUM)
  647.                LAST = ZYPREV(SPTR)
  648.                UNROLL = .FALSE.
  649.  
  650. C Write the clean up loop.
  651. C Write the DO statement.
  652. C DO
  653.                   CALL ZTOKWR(TDO,0,DUMMY(1),TKNCHN)
  654. C label reference (label generated earlier by GETIL)
  655.                  CALL ZTOKWR(TDCNST,LENGTH(NEWLBL),NEWLBL,TKNCHN)
  656. C DO variable
  657.                   CALL ZTOKWR(TNAME,LENGTH(DOVAR),DOVAR,TKNCHN)
  658. C =
  659.                   CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
  660. C E2' = Myyyyy
  661.                  CALL ZTOKWR(TNAME,LENGTH(E2DASH),E2DASH,TKNCHN)
  662. C +
  663.                   CALL ZTOKWR(TPLUS,0,DUMMY(1),TKNCHN)
  664. C unrolling depth
  665.                  CALL ZTOKWR(TDCNST,LENGTH(DEPTH),DEPTH,TKNCHN)
  666. C *(E3) - omit if E3 = default (1).
  667.                IF (E3NOD .NE. 0) THEN
  668.                     CALL ZTOKWR(TSTAR,0,DUMMY(1),TKNCHN)
  669.                     CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  670.                   CALL YEXPR(E3NOD,TKNCHN)
  671.                     CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  672.                END IF
  673. C ,
  674.                   CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
  675. C E2
  676.                CALL YEXPR(E2NOD,TKNCHN)
  677. C ,E3 - omit if E3 = default (1).
  678.                IF (E3NOD .NE. 0) THEN
  679.                      CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
  680.                   CALL YEXPR(E3NOD,TKNCHN)
  681.                END IF
  682. C end-of-statement (DO for clean-up loop)
  683.                   CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  684.  
  685. C Output any block of comments that followed original DO.
  686.                CALL COMOUT(SAVCOM)
  687.  
  688. C Set up and/or reset the correspondence between old and new labels.
  689.                CALL SETLAB(FIRST,LAST,J)
  690. C Output statements in the clean-up loop.
  691.              POINTR = FIRST
  692. 400             TYPE = NODETP(POINTR)
  693.                IF (TYPE .EQ. 62) THEN
  694.                   LBLNOD = ZYDOWN(POINTR)
  695.                   IF (NODETP(LBLNOD) .EQ. 115) THEN
  696. C Get the replacement label.
  697.                      CALL GETLAB(LBLNOD,LABLN,FOUND)
  698.                      IF (.NOT. FOUND) CALL ERROR('ISTUD: Label'
  699.      +                  //'  On CONTINUE Not Found.')
  700. C Write CONTINUE with new label.
  701.                          CALL ZTOKWR(TDCNST,LENGTH(LABLN),
  702.      +                             LABLN,TKNCHN)
  703.                         CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
  704. C end-of-statement (CONTINUE statement)
  705.                         CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  706.                   ELSE
  707. C Unlabelled CONTINUE. Output it.
  708.                         CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
  709. C end-of-statement (CONTINUE statement)
  710.                         CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  711.                   END IF
  712.                ELSE IF (TYPE .EQ. 51) THEN
  713. C Get the replacement label reference if there is one.
  714. C (Recall that all labels must be on CONTINUE statements.  Hence,
  715. C the GO TO is not labelled.)
  716.                   CALL GETLAB(ZYDOWN(POINTR),LABLN,FOUND)
  717.                   IF (.NOT. FOUND) THEN
  718. C Label not found and hence is a transfer out of the DO loop.
  719. C Output statement as it stands.
  720.                      CALL YSTMT(POINTR,TKNCHN)
  721.                   ELSE
  722. C Write GO TO with new label reference.
  723.                        CALL ZTOKWR(TGOTO,0,DUMMY(1),TKNCHN)
  724.                          CALL ZTOKWR(TDCNST,LENGTH(LABLN),LABLN,
  725.      +                             TKNCHN)
  726. C end-of-statement (GO TO statement)
  727.                        CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  728.                   END IF
  729.                ELSE IF (TYPE .EQ. 61) THEN
  730. C Get replacement for termination label. We require that each DO range
  731. C end on its own CONTINUE.
  732.                   CALL GETLAB(ZYDOWN(POINTR),LABLN,FOUND)
  733. C Write DO with new label reference.
  734.                   IF (.NOT. FOUND) CALL ERROR('ISTUD: Label'
  735.      +                         //' Reference for DO Not Found.')
  736.                   CALL DOTRM(POINTR,LABLN,TKNCHN)
  737.                ELSE IF (TYPE .EQ. 57 .OR. TYPE .EQ. 55
  738.      +            .OR. TYPE .EQ. 58 .OR. TYPE .EQ. 56) THEN
  739.                   CALL IFLAB(POINTR,TKNCHN)
  740.                ELSE
  741.                     CALL YSTMT(POINTR,TKNCHN)
  742.                END IF
  743.                SAVCOM = SAVCOM + 1
  744.                CALL COMOUT(SAVCOM)
  745.               IF (POINTR .NE. LAST) THEN
  746.                 POINTR = ZYNEXT(POINTR)
  747.                 GO TO 400
  748.               ELSE
  749. C Output CONTINUE for end of clean up loop.
  750. C label
  751.                 CALL ZTOKWR(TDCNST,LENGTH(NEWLBL),NEWLBL,TKNCHN)
  752. C CONTINUE
  753.                 CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
  754. C end-of-statement (CONTINUE statement)
  755.                      CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  756.                END IF
  757. C End clean up loop.
  758.                GO TO 600
  759.              END IF
  760.          END IF
  761. C
  762. C
  763. C We've finished the processing associated with the discovery
  764. C of the labelled statement (CONTINUE) that is the end of the range
  765. C of the DO being unrolled.  The following processing is for unlabelled
  766. C statements in the range and CONTINUEs with labels (we postponed labelled
  767. C CONTINUEs till here.
  768.             TYPE = NODETP(SPTR)
  769. C If J > 0, modify the labels on CONTINUEs.
  770.          IF (TYPE .EQ. 62 .AND. J .GT. 0) THEN
  771.             LBLNOD = ZYDOWN(SPTR)
  772.             IF (NODETP(LBLNOD) .EQ. 115) THEN
  773.                CALL GETLAB(LBLNOD,LABLN,FOUND)
  774.                IF (.NOT. FOUND) CALL ERROR('ISTUD: Label Not Found'
  775.      +                         //' On Labelled CONTINUE.')
  776. C Write CONTINUE with new label.
  777.                    CALL ZTOKWR(TDCNST,LENGTH(LABLN),LABLN,
  778.      +                       TKNCHN)
  779.                  CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
  780. C end-of-statement (CONTINUE statement)
  781.                  CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  782.             ELSE
  783. C Unlabelled CONTINUE.  Ouput it.
  784.                   CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
  785. C end-of-statement (CONTINUE statement)
  786.                   CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  787.             END IF
  788. C If J > 0, modify the label references in GO TOs as appropriate.
  789.          ELSE IF (TYPE .EQ. 51 .AND. J .GT. 0) THEN
  790. C We require that all labels be on CONTINUES; hence GO TO
  791. C is not labelled.
  792.             CALL GETLAB(ZYDOWN(SPTR),LABLN,FOUND)
  793.             IF (.NOT. FOUND) THEN
  794. C Label not found and hence is a transfer out of the DO loop.
  795. C Output statement as it stands.
  796.                CALL YSTMT(SPTR,TKNCHN)
  797.             ELSE
  798. C Write GO TO with new label reference.
  799.                  CALL ZTOKWR(TGOTO,0,DUMMY(1),TKNCHN)
  800.                    CALL ZTOKWR(TDCNST,LENGTH(LABLN),LABLN,
  801.      +                       TKNCHN)
  802. C end-of-statement (GO TO statement)
  803.                  CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  804.             END IF
  805. C If J > 0, modify assignment statements that contain the DO variable.
  806.             ELSE IF (TYPE .EQ. 49 .AND. J .GT. 0) THEN
  807.             IF (NAMEP(SPTR,DOVAR) .EQ. -2) THEN
  808. C Assignment statement contains the DO variable.
  809. C Replace DOVAR with J*E3.
  810.                NRDIGS = ITOC(J,ICON,WIDTH)
  811.                IF (NDEQM1(E3NOD) .EQ. -2) THEN
  812.                   INCNOD = -1
  813.                ELSE
  814.                   INCNOD = E3NOD
  815.                END IF
  816.                  CALL UASGU(SPTR,DOVAR,ICON,INCNOD,TKNCHN)
  817.             ELSE
  818. C Output as it stands.
  819.                  CALL YSTMT(SPTR,TKNCHN)
  820.             END IF
  821. C All labels in unrolling range are on CONTINUEs; hence inner DO
  822. C is not labelled.
  823.          ELSE IF (TYPE .EQ. 61 .AND. J .GT. 0) THEN
  824.             CALL GETLAB(ZYDOWN(SPTR),LABLN,FOUND)
  825.             IF (.NOT. FOUND) CALL ERROR('ISTUD: Cannot Find'
  826.      +           //' Replacement Label Reference On Inner DO.')
  827.             IF (NAMEP(ZYNEXT(ZYDOWN(SPTR)),DOVAR) .EQ. -2) THEN
  828. C Nested DO specification contains the DO variable for the unrolling DO.
  829. C Replace DOVAR with J*E3.
  830.                NRDIGS = ITOC(J,ICON,WIDTH)
  831.                IF (NDEQM1(E3NOD) .EQ. -2) THEN
  832.                   INCNOD = -1
  833.                ELSE
  834.                   INCNOD = E3NOD
  835.                END IF
  836.                  CALL UDO(SPTR,DOVAR,ICON,INCNOD,LABLN,TKNCHN)
  837.             ELSE
  838. C DO specification independent of DOVAR but we still have to fix the label.
  839.                  CALL DOTRM(SPTR,LABLN,TKNCHN)
  840.             END IF
  841. C If J > 0, modify IF statements.
  842.          ELSE IF ((TYPE .EQ. 57 .OR. TYPE .EQ. 55
  843.      +            .OR. TYPE .EQ. 58 .OR. TYPE .EQ. 56)
  844.      +            .AND. (J .GT. 0)) THEN
  845.             IF (NAMEP(SPTR,DOVAR) .EQ. -2) THEN
  846. C IF contains the DO variable.
  847.                NRDIGS = ITOC(J,ICON,WIDTH)
  848.                IF (NDEQM1(E3NOD) .EQ. -2) THEN
  849.                   INCNOD = -1
  850.                ELSE
  851.                   INCNOD = E3NOD
  852.                END IF
  853.                CALL UIF(SPTR,DOVAR,ICON,INCNOD,TKNCHN)
  854.             ELSE
  855. C IF does not contain the DO variable but we must fix the labels.
  856.                CALL IFLAB(SPTR,TKNCHN)
  857.             END IF
  858.          ELSE
  859. C We are unrolling and either J = 0 and/or type is not GO TO, CONTINUE, DO,
  860. C IF, or assignment.
  861.               CALL YSTMT(SPTR,TKNCHN)
  862.             IF (J .EQ. 0) THEN
  863.                SNUM = SNUM + 1
  864.                CALL COMOUT(SNUM)
  865.             END IF
  866.          END IF
  867.       ELSE
  868. C We are not unrolling.
  869.            CALL YSTMT(SPTR,TKNCHN)
  870.          SNUM = SNUM + 1
  871.          CALL COMOUT(SNUM)
  872.       END IF
  873. 600     CONTINUE
  874.         SPTR=ZYNEXT(SPTR)
  875.         IF (SPTR.NE.0) GO TO 100
  876.  
  877.         END
  878. C--------   SETLAB.MAC
  879. C ----------------------------------------------------------------------------
  880. C       S E T L A B - Set label correspondence
  881. C
  882.       SUBROUTINE SETLAB(NODF,NODL,LEVEL)
  883.  
  884.       INTEGER NODF,NODL,LEVEL
  885.  
  886. C If LEVEL=0, fill OLDLBS with the labels for the statements
  887. C whose parse tree nodes are NODF to NODL inclusive and write
  888. C replacements for the labels in the corresponding cells in NEWLBS.
  889. C If LEVEL .ne. 0, replace the replacements in NEWLBS with a new set.
  890. C NRLBS is the number of labels (max. 200).
  891. C SETLAB is called by PROPU to supply new labels for a DO loop that
  892. C is being unrolled.
  893.  
  894.       COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  895.       INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  896.  
  897.       COMMON/LABLST/OLDLBS,NEWLBS,NRLBS
  898.       INTEGER OLDLBS(6,200),NEWLBS(6,200),NRLBS
  899.  
  900.       INTEGER SPTR,LBLNOD,SYMVAL(8),I,JUNK(7)
  901.  
  902.       INTEGER ZYDOWN,ZYNEXT,NODETP
  903.       EXTERNAL ZYDOWN,ZYNEXT,NODETP,ZYGTSY,ZYGTST,GETIL
  904.  
  905. C Set up OLDLBS if LEVEL = 0.
  906.       IF (LEVEL .EQ. 0) THEN
  907.          NRLBS = 0
  908.          SPTR = NODF
  909.   100    LBLNOD = ZYDOWN(SPTR)
  910.            IF (NODETP(LBLNOD) .EQ. 115) THEN
  911.              NRLBS = NRLBS + 1
  912.              OLDLBS(1,NRLBS) = 129
  913.              CALL ZYGTSY(-ZYDOWN(LBLNOD),SYMVAL)
  914.              CALL ZYGTST(SYMVAL(2),OLDLBS(1,NRLBS))
  915.            END IF
  916.          IF (SPTR .NE. NODL) THEN
  917.            SPTR = ZYNEXT(SPTR)
  918.            GO TO 100
  919.          END IF
  920.       END IF
  921.  
  922. C Fill NEWLBS with a set of label replacements.
  923.       DO 200 I = 1,NRLBS
  924.          CALL GETIL(JUNK,NEWLBS(1,I))
  925. 200   CONTINUE
  926.  
  927.       END
  928. C--------   URCOND.MAC
  929. C ----------------------------------------------------------------------
  930. C
  931. C       U R C O N D  -   Determine whether the DO loop meets the conditions
  932. C                   for unrolling.
  933. C
  934.  
  935.         INTEGER FUNCTION URCOND(DONODE,ISLBLD,IND,LBL)
  936.  
  937. C DONODE is the parse tree node of the DO statement, IND the index, and
  938. C LBL the terminating label.  ISLBLD is .TRUE. or .FALSE. according to
  939. C whether the DO statement itself is labelled or not.  All are input
  940. C arguments.
  941.  
  942. C  URCOND returns 'no' if any of the following conditions
  943. C  are encountered in the DO statement at DONODE or its associated
  944. C  range.
  945. C
  946. C  (1) the loop is trivial (range has only one statement),
  947. C
  948. C  (2) the range contains a labelled statement that is not a
  949. C  CONTINUE,
  950. C
  951. C  (3) the range contains a non-assignment statement, other than a DO,
  952. C  or IF in which the DO variable occurs,
  953. C
  954. C  (4) the DO does not terminate on a CONTINUE,
  955. C
  956. C  (5) The DO is in the range of a DO rejected for unrolling.
  957. C
  958. C  (6) There is a transfer to the terminating label with a GO TO.
  959. C
  960. C  (7) An inner DO does not use the same terminating label as the
  961. C  DO being checked.
  962. C
  963. C  Otherwise, 'yes' is returned.
  964.  
  965.       INTEGER DONODE,IND(*),LBL(*)
  966.       LOGICAL ISLBLD
  967.  
  968.       INTEGER SYMVAL(8), LBLNOD,TEXT(132),SPTR,
  969.      +        DOSPEC,INRLST(200),INNR,I,TYPE
  970.  
  971.  
  972.       COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  973.       INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  974.  
  975.       INTEGER ZYDOWN,ZYNEXT,NAMEP,NODETP,EQUAL
  976.       EXTERNAL ZYDOWN,ZYNEXT,NAMEP,NODETP,ZYGTSY,ZYGTST,ZMESS,
  977.      +         SCOPY
  978.  
  979.  
  980. C---------------------------------------------------------
  981. C    TOOLPACK/1    Release: 2.1
  982. C---------------------------------------------------------
  983. C
  984. C  TKLAST = LAST TOKEN NUMBER
  985. C
  986.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  987.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  988.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  989.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  990.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  991.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  992.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  993.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  994.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  995.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  996.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  997.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  998.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  999.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  1000.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  1001.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  1002.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  1003.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  1004.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  1005.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  1006.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  1007.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  1008.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  1009.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  1010.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  1011.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  1012.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  1013.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  1014.  
  1015.  
  1016.       SAVE
  1017.       DATA INNR /0/
  1018.  
  1019. C Is the DO is on the list of DOs inner to a rejected DO?
  1020.       DO 300 I = 1,INNR
  1021.          IF (DONODE .EQ. INRLST(I)) THEN
  1022.             TEXT(1) = 129
  1023.             CALL TITLE(TEXT,'Inner DO in the range of a rejected DO.')
  1024.             URCOND = -3
  1025. C No need to proceed further through the range.
  1026.             RETURN
  1027.          END IF
  1028.   300 CONTINUE
  1029.  
  1030.       IF (ISLBLD) THEN
  1031.          DOSPEC = ZYNEXT(ZYNEXT(ZYDOWN(DONODE)))
  1032.       ELSE
  1033.          DOSPEC = ZYNEXT(ZYDOWN(DONODE))
  1034.       END IF
  1035.  
  1036. C Does the DO loop have only one statement in its range?
  1037.       SPTR = ZYNEXT(DONODE)
  1038.       TEXT(1) = 129
  1039.       LBLNOD = ZYDOWN(SPTR)
  1040.         IF (NODETP(LBLNOD) .EQ. 115) THEN
  1041.           CALL ZYGTSY(-ZYDOWN(LBLNOD),SYMVAL)
  1042.           CALL ZYGTST(SYMVAL(2),TEXT)
  1043.           IF (EQUAL(TEXT,LBL) .EQ. -2) THEN
  1044.             CALL TITLE(TEXT, 'Only one statement in range of DO.')
  1045.             URCOND = -3
  1046.             RETURN
  1047.           END IF
  1048.       END IF
  1049.  
  1050.   100 CONTINUE
  1051.       TYPE = NODETP(SPTR)
  1052.  
  1053. C When a DO is encountered in the range, put its node on the list
  1054. C INRLST.  This list will be used to detect inner DOs that are to be
  1055. C rejected with the outer DO is rejected.  Also check that the inner
  1056. C DO does not use the same terminating label as the DO being examined.
  1057.  
  1058.       IF(TYPE .EQ. 61) THEN
  1059.          INNR = INNR + 1
  1060.          INRLST(INNR) = SPTR
  1061.  
  1062.          LBLNOD = ZYDOWN(SPTR)
  1063.          IF (NODETP(LBLNOD) .EQ. 115) LBLNOD = ZYNEXT(LBLNOD)
  1064.          CALL GETSTR(LBLNOD,TEXT)
  1065.          IF (EQUAL(TEXT,LBL) .EQ. -2) THEN
  1066.             CALL TITLE(TEXT, 'Inner DO uses same terminating label'
  1067.      +                    //' as outer DO.')
  1068.             URCOND = -3
  1069.             GO TO 200
  1070.          END IF
  1071.       END IF
  1072.  
  1073. C Does the DO variable occur in a statement that is not a DO, IF
  1074. C or assignment?
  1075.       IF (TYPE .NE. 49 .AND. TYPE .NE. 61 .AND.
  1076.      +      TYPE .NE. 57 .AND. TYPE .NE. 55 .AND.
  1077.      +      TYPE .NE. 58 .AND. TYPE .NE. 56 .AND.
  1078.      +      NAMEP(SPTR,IND) .EQ. -2) THEN
  1079.          TEXT(1) = 129
  1080.          CALL TITLE(TEXT, 'Index occurs in statement that is neither'
  1081.      +                //' an assignment, DO, nor IF.')
  1082.          URCOND = -3
  1083.          GO TO 200
  1084.       END IF
  1085.  
  1086. C Does the range contain a transfer to the terminating label?
  1087.       IF (TYPE .EQ. 51) THEN
  1088.          LBLNOD = ZYDOWN(SPTR)
  1089.            IF (NODETP(LBLNOD) .EQ. 115) LBLNOD = ZYNEXT(LBLNOD)
  1090.            CALL GETSTR(LBLNOD,TEXT)
  1091.            IF (EQUAL(TEXT,LBL) .EQ. -2) THEN
  1092.              CALL TITLE(TEXT, 'Range contains transfer to terminating'
  1093.      +                    //' statement.')
  1094.              URCOND = -3
  1095.              GO TO 200
  1096.            END IF
  1097.       END IF
  1098.  
  1099.       IF (TYPE .EQ. 56) THEN
  1100.          LBLNOD = ZYDOWN(SPTR)
  1101.            IF (NODETP(LBLNOD) .EQ. 115) LBLNOD = ZYNEXT(LBLNOD)
  1102.            LBLNOD = ZYNEXT(LBLNOD)
  1103. C LBLNOD is now the node of the statement executed when IF true.
  1104.            IF (NODETP(LBLNOD) .EQ. 51) THEN
  1105.              LBLNOD = ZYDOWN(LBLNOD)
  1106.              CALL GETSTR(LBLNOD,TEXT)
  1107.              IF (EQUAL(TEXT,LBL) .EQ. -2) THEN
  1108.                CALL TITLE(TEXT, 'Range contains transfer to terminating'
  1109.      +                    //' statement.')
  1110.                URCOND = -3
  1111.                GO TO 200
  1112.              END IF
  1113.         END IF
  1114.       END IF
  1115.  
  1116. C Does the range contain a labelled statement that is
  1117. C not a CONTINUE?
  1118.       LBLNOD = ZYDOWN(SPTR)
  1119.         IF (NODETP(LBLNOD) .EQ. 115) THEN
  1120. C Get the label and check if it is the termination label.
  1121.           CALL ZYGTSY(-ZYDOWN(LBLNOD),SYMVAL)
  1122.           CALL ZYGTST(SYMVAL(2),TEXT)
  1123.           IF (EQUAL(TEXT,LBL) .EQ. -3) THEN
  1124.             IF (NODETP(SPTR) .NE. 62) THEN
  1125.                CALL TITLE(TEXT, 'Range contains labelled statement that'
  1126.      +                    //' is n'//'ot a CONTINUE.')
  1127.                URCOND = -3
  1128.                GO TO 200
  1129.             END IF
  1130. C We have arrived at the termination of the DO being checked.
  1131. C Is the termination statement a CONTINUE?
  1132.           ELSE IF (NODETP(SPTR) .NE. 62) THEN
  1133.             CALL TITLE(TEXT, 'DO termination statement'
  1134.      +                 //' is n'//'ot a CONTINUE.')
  1135.             URCOND = -3
  1136. C No need to complete list of inner DOs since we are at termination.
  1137.             RETURN
  1138.           ELSE
  1139. C The DO passes the conditions for unrolling.  Discard the list of
  1140. C nodes in INRLST.
  1141.             URCOND = -2
  1142.             INNR = 0
  1143.             RETURN
  1144.           END IF
  1145.       END IF
  1146.  
  1147. C Go on to next statement in range of DO
  1148.       SPTR = ZYNEXT(SPTR)
  1149.       GO TO 100
  1150.  
  1151. C The DO at DONODE has been rejected for unrolling.  Continue through
  1152. C the range, placing the nodes of inner DOs on INRLST.
  1153. 200      CONTINUE
  1154.       SPTR = ZYNEXT(SPTR)
  1155.       LBLNOD = ZYDOWN(SPTR)
  1156.         IF (NODETP(LBLNOD) .EQ. 115) THEN
  1157.           CALL ZYGTSY(-ZYDOWN(LBLNOD),SYMVAL)
  1158.           CALL ZYGTST(SYMVAL(2),TEXT)
  1159.           IF (EQUAL(TEXT,LBL) .EQ. -2) RETURN
  1160.         END IF
  1161.       IF (NODETP(SPTR) .EQ. 61) THEN
  1162.             INNR = INNR + 1
  1163.             INRLST(INNR) = SPTR
  1164.       END IF
  1165.       GO TO 200
  1166.  
  1167.       END
  1168.